home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / TURBOPASCAL WIN / OWLDEMOS.PAK / PXACCESS.PAS < prev    next >
Pascal/Delphi Source File  |  1992-06-08  |  7KB  |  280 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Paradox Engine demo access unit              }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. unit PXAccess;
  10.  
  11. interface
  12.  
  13. {$N+}
  14.  
  15. uses WObjects, PXEngine;
  16.  
  17. type
  18.   PFieldArray = ^TFieldArray;
  19.   TFieldArray = array[1..256] of PChar;
  20.  
  21. type
  22.   PPXTable = ^TPXTable;
  23.   TPXTable = object(TObject)
  24.     Status: Integer;
  25.     constructor Init(TableName: PChar);
  26.     destructor Done; virtual;
  27.     procedure ClearError;
  28.     function FieldName(Field: Integer): PChar;
  29.     function FieldType(Field: Integer): PChar;
  30.     function FieldWidth(Field: Integer): Integer;
  31.     function GetField(Rec, Fld: Integer): PChar;
  32.     function NumRecords: LongInt;
  33.     function NumFields: Integer;
  34.     procedure PXError(Error: Integer); virtual;
  35.   private
  36.     CurRecord: Integer;
  37.     TblHandle: TableHandle;
  38.     RecHandle: RecordHandle;
  39.     NumFlds: Integer;
  40.     NumRecs: LongInt;
  41.     FieldNames: PFieldArray;
  42.     FieldTypes: PFieldArray;
  43.     Cache: Pointer;
  44.     function CheckError(Code: Integer): Boolean;
  45.   end;
  46.  
  47. implementation
  48.  
  49. uses WinTypes, WinProcs, Strings;
  50.  
  51. type
  52.   PCache = ^TCache;
  53.   TCache = object(TCollection)
  54.     constructor Init(CacheSize: Integer);
  55.     procedure Add(Index: LongInt; P: PChar);
  56.     function Get(Index: LongInt): PChar;
  57.     procedure FreeItem(P: Pointer); virtual;
  58.   end;
  59.  
  60. type
  61.   PCacheElement = ^TCacheElement;
  62.   TCacheElement = record
  63.     Index: LongInt;
  64.     Item: PChar;
  65.   end;
  66.  
  67. constructor TCache.Init(CacheSize: Integer);
  68. begin
  69.   TCollection.Init(CacheSize, 0);
  70. end;
  71.  
  72. procedure TCache.Add(Index: LongInt; P: PChar);
  73. var
  74.   CE: PCacheElement;
  75. begin
  76.   New(CE);
  77.   CE^.Index := Index;
  78.   CE^.Item := P;
  79.   if Count = Limit then AtFree(Count - 1);
  80.   AtInsert(0, CE);
  81. end;
  82.  
  83. function TCache.Get(Index: LongInt): PChar;
  84. var
  85.   P: PCacheElement;
  86.  
  87.   function ItemWithIndex(P: PCacheElement): Boolean; far;
  88.   begin
  89.     ItemWithIndex := P^.Index = Index;
  90.   end;
  91.  
  92. begin
  93.   Get := nil;
  94.   P := FirstThat(@ItemWithIndex);
  95.   if P <> nil then Get := P^.Item;
  96. end;
  97.  
  98. procedure TCache.FreeItem(P: Pointer);
  99. begin
  100.   StrDispose(PCacheElement(P)^.Item);
  101.   Dispose(P);
  102. end;
  103.  
  104. { TPXTable }
  105.  
  106. constructor TPXTable.Init(TableName: PChar);
  107. var
  108.   Temp: array[0..25] of Char;
  109.   I: Integer;
  110. begin
  111.   FieldTypes := nil;
  112.   FieldNames := nil;
  113.   Cache := nil;
  114.   Status := 0;
  115.   CurRecord := -1;
  116.   if CheckError(PXTblOpen(TableName, TblHandle, 0, True)) and
  117.      CheckError(PXRecBufOpen(TblHandle, RecHandle)) and
  118.      CheckError(PXRecNFlds(TblHandle, NumFlds)) and
  119.      CheckError(PXTblNRecs(TblHandle, NumRecs)) then
  120.   begin
  121.     GetMem(FieldTypes, NumFields * SizeOf(PChar));
  122.     GetMem(FieldNames, NumFields * SizeOf(PChar));
  123.     for I := 1 to NumFields do
  124.     begin
  125.       CheckError(PXFldName(TblHandle, I, SizeOf(Temp), Temp));
  126.       FieldNames^[I] := StrNew(Temp);
  127.       CheckError(PXFldType(TblHandle, I, SizeOf(Temp), Temp));
  128.       FieldTypes^[I] := StrNew(Temp);
  129.     end;
  130.     Cache := New(PCache, Init(300));
  131.   end;
  132. end;
  133.  
  134. destructor TPXTable.Done;
  135. var
  136.   I: Integer;
  137. begin
  138.   TObject.Done;
  139.   PXRecBufClose(RecHandle);
  140.   PXTblClose(TblHandle);
  141.   if (FieldTypes <> nil) and (FieldNames <> nil) then
  142.     for I := 1 to NumFields do
  143.     begin
  144.       StrDispose(FieldNames^[I]);
  145.       StrDispose(FieldTypes^[I]);
  146.     end;
  147.   if FieldTypes <> nil then FreeMem(FieldTypes, NumFields * SizeOf(PChar));
  148.   if FieldNames <> nil then FreeMem(FieldNames, NumFields * SizeOf(PChar));
  149.   if Cache <> nil then Dispose(PCache(Cache), Done);
  150. end;
  151.  
  152. function TPXTable.CheckError(Code: Integer): Boolean;
  153. begin
  154.   if Status = 0 then
  155.   begin
  156.     if Code <> 0 then PXError(Code);
  157.     Status := Code;
  158.   end;
  159.   CheckError := Status = 0;
  160. end;
  161.  
  162. procedure TPXTable.ClearError;
  163. begin
  164.   Status := 0;
  165. end;
  166.  
  167. function TPXTable.FieldName(Field: Integer): PChar;
  168. begin
  169.   FieldName := FieldNames^[Field];
  170. end;
  171.  
  172. function TPXTable.FieldType(Field: Integer): PChar;
  173. begin
  174.   FieldType := FieldTypes^[Field];
  175. end;
  176.  
  177. function TPXTable.FieldWidth(Field: Integer): Integer;
  178. var
  179.   Width, Code: Integer;
  180. begin
  181.   case FieldTypes^[Field][0] of
  182.     'N',
  183.     '$': FieldWidth := 14;
  184.     'A':
  185.       begin
  186.     Val(PChar(@FieldTypes^[Field][1]), Width, Code);
  187.     FieldWidth := Width
  188.       end;
  189.     'D': FieldWidth := 12;
  190.     'S': FieldWidth := 8;
  191.   else
  192.     FieldWidth := 0;
  193.   end;
  194. end;
  195.  
  196. function TPXTable.GetField(Rec, Fld: Integer): PChar;
  197. const
  198.   TheData: array[0..255] of Char = '';
  199. var
  200.   Tmp: array[0..255] of Char;
  201.   N: Double;
  202.   I: Integer;
  203.   L: LongInt;
  204.   ArgList: array[0..2] of Integer;
  205.   Index: LongInt;
  206.   P: PChar;
  207. begin
  208.   TheData[0] := #0;
  209.   GetField := TheData;
  210.   if Status <> 0 then Exit;
  211.   if (Rec < 1) or (Rec > NumRecords) then Exit;
  212.   if (Fld < 1) or (Fld > NumFields) then Exit;
  213.   Index := Rec * NumFields + Fld;
  214.   P := PCache(Cache)^.Get(Index);
  215.   if P = nil then
  216.   begin
  217.     if Rec <> CurRecord then
  218.     begin
  219.       CheckError(PXRecGoto(TblHandle, Rec));
  220.       CheckError(PXRecGet(TblHandle, RecHandle));
  221.       CurRecord := Rec;
  222.     end;
  223.     FillChar(TheData, SizeOf(TheData), ' ');
  224.     Tmp[0] := #0;
  225.     case FieldTypes^[Fld][0] of
  226.       'A':
  227.     CheckError(PXGetAlpha(RecHandle, Fld, SizeOf(Tmp), Tmp));
  228.       'N':
  229.     begin
  230.       CheckError(PXGetDoub(RecHandle, Fld, N));
  231.       if not IsBlankDouble(N) then
  232.         Str(N:12:4, Tmp);
  233.     end;
  234.       '$':
  235.     begin
  236.       CheckError(PXGetDoub(RecHandle, Fld, N));
  237.       if not IsBlankDouble(N) then
  238.         Str(N:12:2, Tmp);
  239.     end;
  240.       'S':
  241.     begin
  242.       CheckError(PXGetShort(RecHandle, Fld, I));
  243.       if not IsBlankShort(i) then
  244.         Str(I:6, Tmp)
  245.     end;
  246.       'D':
  247.     begin
  248.       CheckError(PXGetDate(RecHandle, Fld, L));
  249.       if Not IsBlankDate(L) then
  250.       begin
  251.         CheckError(PXDateDecode(L, ArgList[0], ArgList[1], ArgList[2]));
  252.         wvSprintf(Tmp, '%2d/%2d/%4d', ArgList);
  253.       end;
  254.     end;
  255.     end;
  256.     StrMove(TheData, Tmp, StrLen(Tmp));
  257.     TheData[FieldWidth(Fld)] := #0;
  258.     PCache(Cache)^.Add(Index, StrNew(TheData));
  259.   end
  260.   else
  261.     GetField := P;
  262. end;
  263.  
  264. function TPXTable.NumRecords: LongInt;
  265. begin
  266.   NumRecords := NumRecs;
  267. end;
  268.  
  269. function TPXTable.NumFields: Integer;
  270. begin
  271.   NumFields := NumFlds;
  272. end;
  273.  
  274. procedure TPXTable.PXError(Error: Integer);
  275. begin
  276.   MessageBox(GetFocus, PXErrMsg(Error), 'PXAccess', mb_OK)
  277. end;
  278.  
  279. end.
  280.